{*******************************************************************************
* The contents of this file are used with permission, subject to the Mozilla   *
* Public License Version 1.1 (the "License"); you may not use this file except *
* in compliance with the License. You may obtain a copy of the License at      *
* http://www.mozilla.org/MPL/                                                  *
*                                                                              *
* Software distributed under the License is distributed on an "AS IS" basis,   *
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for *
* the specific language governing rights and limitations under the License.    *
*                                                                              *
* The Original Code is distributed as part of the "mediate" product and is     *
* Copyright (C) @home media limited. All Rights Reserved.                      *
*                                                                              *
* Email: support@athomemedia.co.uk                                             *
* Web:   http://www.athomemedia.co.uk                                          *
*******************************************************************************}

unit Colour;

interface

uses Classes, Graphics, Types, AHMTypes;

type
  TColourType = (ctBlue, ctGreen, ctRed, ctAlpha);
  TColourPixel = array[TColourType] of Byte;
  TColourAdjust = array[TColourType] of Single;
  PColourPixel = ^TColourPixel;

  // Array of pixels type for rapid manipulation of colour data
  PPixelArray = ^TPixelArray;
  TPixelArray = array[0..32767] of TColourPixel;
  P16bitPixelArray = ^T16bitPixelArray;
  T16bitPixelArray = array[0..32767] of Word;

  TPixelPointer = ^DWORD;

  TAHMCanvasColour = class(TPersistent)
  private
    FPixel: TColourPixel;
  protected
    function GetInternalColor: TColor;
    function GetInternalAlpha: Byte;
    procedure SetInternalAlpha(Alpha: Byte);
    procedure SetPixel(Pixel: TColourPixel);
    function GetInternalARGB: DWORD;
    procedure SetInternalARGB(ARGB: DWORD);
  public
    constructor Create;
    constructor CreateARGB(Alpha, Red, Green, Blue: Byte);
    property InternalARGB: DWORD read GetInternalARGB write SetInternalARGB;
    property Pixel: TColourPixel read FPixel write SetPixel;
    function GammaCorrect(Gamma: TAHMCanvasColour): TColourPixel;
    function InternalGammaCorrect(Gamma: TAHMCanvasColour): DWORD;
    procedure Assign(Source: TPersistent); override;
    // Class functions for standard colours
    class function Black: TAHMCanvasColour;
    class function White: TAHMCanvasColour;
    class function Grey: TAHMCanvasColour;
    class function Highlight: TAHMCanvasColour;
    class function GradientLo: TAHMCanvasColour;
    class function GradientHi: TAHMCanvasColour;
  published
    property InternalColor: TColor read GetInternalColor;
    property InternalAlpha: Byte read GetInternalAlpha write SetInternalAlpha;
  end;

  TAHMCanvasShade = class
  private
    FRectSet: Boolean;
    FRectSetCount: Integer;
    FShadeRect: TAHMRectF;
    FTLColour: TAHMCanvasColour;
    FTRColour: TAHMCanvasColour;
    FBLColour: TAHMCanvasColour;
    FBRColour: TAHMCanvasColour;
  protected
    procedure SetSingleColour(Colour: TAHMCanvasColour);
    function GetValid: Boolean; virtual;
    procedure SetupShadeRect; virtual;
    procedure CleanupShadeRect; virtual;
  public
    property TopLeft: TAHMCanvasColour read FTLColour write FTLColour;
    property TopRight: TAHMCanvasColour read FTRColour write FTRColour;
    property BottomLeft: TAHMCanvasColour read FBLColour write FBLColour;
    property BottomRight: TAHMCanvasColour read FBRColour write FBRColour;
    property SingleColour: TAHMCanvasColour read FTLColour write SetSingleColour;
    property ShadeRectSet: Boolean read FRectSet;
    property Valid: Boolean read GetValid;
    function BeginShadeRect(Rect: TAHMRectF): Boolean;
    procedure EndShadeRect;
    procedure ShadeLine(Rect: TAHMRectF); virtual;
    procedure ShadeChar(Rect: TAHMRectF); virtual;
    procedure ShadeRect(Rect: TAHMRectF); virtual;
    procedure ShadePoint(X, Y: Single); virtual;
  end;

  TAHMCanvasGradientShade = class(TAHMCanvasShade)
  private
    FPrevTLColour: TAHMCanvasColour;
    FPrevTRColour: TAHMCanvasColour;
    FPrevBLColour: TAHMCanvasColour;
    FPrevBRColour: TAHMCanvasColour;
    FTAdjust: TColourAdjust;
    FBAdjust: TColourAdjust;
    FLAdjust: TColourAdjust;
    FRAdjust: TColourAdjust;
    FVTLPixel: TColourPixel;
    FVTRPixel: TColourPixel;
    FVBLPixel: TColourPixel;
    FVBRPixel: TColourPixel;
    FHTLPixel: TColourPixel;
    FHTRPixel: TColourPixel;
    FHBLPixel: TColourPixel;
    FHBRPixel: TColourPixel;
  protected
    procedure SetupShadeRect; override;
    procedure CleanupShadeRect; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ShadeLine(Rect: TAHMRectF); override;
    procedure ShadeChar(Rect: TAHMRectF); override;
    procedure ShadeRect(Rect: TAHMRectF); override;
    procedure ShadePoint(X, Y: Single); override;
  end;

  TAHMCanvasLinearShade = class(TAHMCanvasShade)
  private
    FTLPixel: TColourPixel;
    FTRPixel: TColourPixel;
    FBLPixel: TColourPixel;
    FColours: TList;
    FPositions: TList;
    FCalcPos: TList;
    FCalcDiff: TList;
    FOrient: TAHMOrientation;
  protected
    function GetValid: Boolean; override;
    function GetCount: Integer;
    function GetPosition(Index: Integer): Single;
    function GetColour(Index: Integer): TAHMCanvasColour;
    procedure SetupShadeRect; override;
  public
    constructor Create;
    destructor Destroy; override;
    property Count: Integer read GetCount;
    property Positions[Index: Integer]: Single read GetPosition;
    property Colours[Index: Integer]: TAHMCanvasColour read GetColour;
    property Orientation: TAHMOrientation read FOrient write FOrient;
    procedure ShadeLine(Rect: TAHMRectF); override;
    procedure ShadeChar(Rect: TAHMRectF); override;
    procedure ShadeRect(Rect: TAHMRectF); override;
    procedure ShadePoint(X, Y: Single); override;
    procedure Clear;
    procedure Add(Position: Single; Colour: TAHMCanvasColour);
  end;

  function ColorToRGBString(Colour: TColor): String;
  function RGBStringToColor(Colour: String): TColor;

implementation

uses
Logging,
SysUtils;

const
  CLEAR_PIXEL: TColourPixel = (255, 255, 255, 255); // White pixel, opaque alpha

var
  BlackInstance: TAHMCanvasColour;
  WhiteInstance: TAHMCanvasColour;
  GreyInstance: TAHMCanvasColour;
  HighlightInstance: TAHMCanvasColour;
  GradientLoInstance: TAHMCanvasColour;
  GradientHiInstance: TAHMCanvasColour;

//----------------------------------------------------------------------------//

function ColorToRGBString(Colour: TColor): String;
var
  Temp: TColor;
begin
  // Swap delphi BGR order around - we want RGB
  Temp := ((Colour and $ff) shl 16) or (Colour and $ff00) or (Colour shr 16);
  Result := IntToHex(Temp, 6);
end;

function RGBStringToColor(Colour: String): TColor;
var
  R,G,B: Byte;
begin
  // Convert passed RGB colour string to TColor
  try
    R := StrToInt('$' + Copy(Colour, 1, 2));
    G := StrToInt('$' + Copy(Colour, 3, 2));
    B := StrToInt('$' + Copy(Colour, 5, 2));
    Result := (B shl 16) or (G shl 8) or R;
  except
    Result := clWhite;
  end;
end;


//----------------------------------------------------------------------------//

constructor TAHMCanvasColour.Create;
begin
  inherited Create;

  // Set default colour (solid white)
  FPixel := CLEAR_PIXEL;
end;

constructor TAHMCanvasColour.CreateARGB(Alpha, Red, Green, Blue: Byte);
begin
  inherited Create;

  // Set passed pixel colour
  FPixel[ctAlpha] := Alpha;
  FPixel[ctRed] := Red;
  FPixel[ctGreen] := Green;
  FPixel[ctBlue] := Blue;
end;

function TAHMCanvasColour.GetInternalColor: TColor;
begin
  // Map our R,G,B values to an internal Delphi TColor value
  Result := FPixel[ctRed] or (FPixel[ctGreen] shl 8) or (FPixel[ctBlue] shl 16);
end;

function TAHMCanvasColour.GetInternalARGB: DWORD;
begin
  // Map our A,R,G,B values to an internal DWORD value suitable for DirectX
  Result := TPixelPointer(@FPixel)^;
end;

function TAHMCanvasColour.GetInternalAlpha: Byte;
begin
  Result := FPixel[ctAlpha];
end;

procedure TAHMCanvasColour.SetInternalAlpha(Alpha: Byte);
begin
  FPixel[ctAlpha] := Alpha;
end;

procedure TAHMCanvasColour.SetInternalARGB(ARGB: DWORD);
begin
  // Update our A,R,G,B values with passed DWORD value suitable for DirectX
  TPixelPointer(@FPixel)^ := ARGB;
end;

procedure TAHMCanvasColour.SetPixel(Pixel: TColourPixel);
begin
  FPixel := Pixel;
end;

function TAHMCanvasColour.GammaCorrect(Gamma: TAHMCanvasColour): TColourPixel;
var
  i: TColourType;
begin
  if Assigned(Gamma) then
  begin
    for i := Low(TColourType) to High(TColourType) do
      Result[i] := Hi(FPixel[i] * Gamma.Pixel[i]);
  end
  else
    Result := FPixel;
end;

function TAHMCanvasColour.InternalGammaCorrect(Gamma: TAHMCanvasColour): DWORD;
var
  Pixel: TColourPixel;
begin
  Pixel := GammaCorrect(Gamma);

  // Dereference typecasted pointer for quick conversion
  Result := TPixelPointer(@Pixel)^;
end;

procedure TAHMCanvasColour.Assign(Source: TPersistent);
begin
  if Source is TAHMCanvasColour then
    Self.FPixel := TAHMCanvasColour(Source).Pixel
  else
    Self.FPixel := CLEAR_PIXEL;
end;

class function TAHMCanvasColour.Black: TAHMCanvasColour;
begin
  if BlackInstance = nil then BlackInstance := CreateARGB(255, 0, 0, 0);
  Result := BlackInstance;
end;

class function TAHMCanvasColour.White: TAHMCanvasColour;
begin
  if WhiteInstance = nil then WhiteInstance := CreateARGB(255, 255, 255, 255);
  Result := WhiteInstance;
end;

class function TAHMCanvasColour.Grey: TAHMCanvasColour;
begin
  if GreyInstance = nil then GreyInstance := CreateARGB(255, 192, 192, 192);
  Result := GreyInstance;
end;

class function TAHMCanvasColour.Highlight: TAHMCanvasColour;
begin
  if HighlightInstance = nil then HighlightInstance := CreateARGB(192, 128, 128, 255);
  Result := HighlightInstance;
end;

class function TAHMCanvasColour.GradientLo: TAHMCanvasColour;
begin
  if GradientLoInstance = nil then GradientLoInstance := CreateARGB(255, 0, 0, 160);
  Result := GradientLoInstance;
end;

class function TAHMCanvasColour.GradientHi: TAHMCanvasColour;
begin
  if GradientHiInstance = nil then GradientHiInstance := CreateARGB(255, 174, 174, 255);
  Result := GradientHiInstance;
end;

// TAHMCanvasShade

procedure TAHMCanvasShade.SetSingleColour(Colour: TAHMCanvasColour);
begin
  // Set all colours the same
  FTLColour := Colour;
  FTRColour := Colour;
  FBLColour := Colour;
  FBRColour := Colour;
end;

function TAHMCanvasShade.GetValid: Boolean;
begin
  Result := Assigned(FTLColour) and Assigned(FTRColour) and
            Assigned(FBLColour) and Assigned(FBRColour);
end;

procedure TAHMCanvasShade.SetupShadeRect;
begin
  // Descendants may implement this if required
end;

procedure TAHMCanvasShade.CleanupShadeRect;
begin
  // Descendants may implement this if required
end;

function TAHMCanvasShade.BeginShadeRect(Rect: TAHMRectF): Boolean;
begin
  // Setup shading rectangle if not already done so
  if FRectSetCount = 0 then
  begin
    // Validate passed rectangle width/height
    Result := GetValid and (Rect.Width > 0) and (Rect.Height > 0);

    // If valid then initialise shading rectangle
    if Result then
    begin
      Inc(FRectSetCount);
      FShadeRect := Rect;
      FRectSet := True;
      SetupShadeRect;
    end;
  end
  else
  begin
    // Already cached shading rectangle so just increment ref. count
    Inc(FRectSetCount);
    Result := True;
  end;
end;

procedure TAHMCanvasShade.EndShadeRect;
begin
  // Cleanup shading rectangle if this is last reference
  if FRectSetCount = 1 then
  begin
    FRectSetCount := 0;
    FRectSet := False;
    CleanupShadeRect;
  end
  else
  begin
    // Nested shading calls so just decrement ref. count
    Dec(FRectSetCount);
  end;
end;

procedure TAHMCanvasShade.ShadeLine(Rect: TAHMRectF);
begin
  // Descendants may implement this if required
end;

procedure TAHMCanvasShade.ShadeChar(Rect: TAHMRectF);
begin
  // Descendants may implement this if required
end;

procedure TAHMCanvasShade.ShadeRect(Rect: TAHMRectF);
begin
  // Descendants may implement this if required
end;

procedure TAHMCanvasShade.ShadePoint(X, Y: Single);
begin
  // Descendants may implement this if required
end;

// TAHMCanvasGradientShade

constructor TAHMCanvasGradientShade.Create;
begin
  inherited;

  // Create additional colours to perform gradient shading calculations
  FPrevTLColour := TAHMCanvasColour.Create;
  FPrevTRColour := TAHMCanvasColour.Create;
  FPrevBLColour := TAHMCanvasColour.Create;
  FPrevBRColour := TAHMCanvasColour.Create;
end;

destructor TAHMCanvasGradientShade.Destroy;
begin
  // Free additional shading calculation colours
  FPrevTLColour.Free;
  FPrevTRColour.Free;
  FPrevBLColour.Free;
  FPrevBRColour.Free;

  inherited;
end;

procedure TAHMCanvasGradientShade.SetupShadeRect;
var
  Colour: TColourType;
begin
  // Store our current shade colours as we'll be updating them
  FPrevTLColour.InternalARGB := FTLColour.InternalARGB;
  FPrevTRColour.InternalARGB := FTRColour.InternalARGB;
  FPrevBLColour.InternalARGB := FBLColour.InternalARGB;
  FPrevBRColour.InternalARGB := FBRColour.InternalARGB;

  // Do some pre-calc stuff for vertical gradient
  for Colour := ctBlue to ctAlpha do
  begin
    FLAdjust[Colour] := (FBLColour.Pixel[Colour] - FTLColour.Pixel[Colour]) / FShadeRect.Height;
    FRAdjust[Colour] := (FBRColour.Pixel[Colour] - FTRColour.Pixel[Colour]) / FShadeRect.Height;
  end;
end;

procedure TAHMCanvasGradientShade.CleanupShadeRect;
begin
  // Restore our original shade colours
  FTLColour.InternalARGB := FPrevTLColour.InternalARGB;
  FTRColour.InternalARGB := FPrevTRColour.InternalARGB;
  FBLColour.InternalARGB := FPrevBLColour.InternalARGB;
  FBRColour.InternalARGB := FPrevBRColour.InternalARGB;
end;

procedure TAHMCanvasGradientShade.ShadeLine(Rect: TAHMRectF);
var
  Colour: TColourType;
  Y1, Y2: Single;
begin
  // Calculate relative vertical coordinates of this line
  Y1 := Rect.Y - FShadeRect.Y;
  Y2 := Y1 + Rect.Height;

  for Colour := ctBlue to ctAlpha do
  begin
    // Initialise top/bottom extents of vertical shade for this line
    FVTLPixel[Colour] := Round(Y1 * FLAdjust[Colour]) + FPrevTLColour.Pixel[Colour];
    FVBLPixel[Colour] := Round(Y2 * FLAdjust[Colour]) + FPrevBLColour.Pixel[Colour];
    FVTRPixel[Colour] := Round(Y1 * FRAdjust[Colour]) + FPrevTRColour.Pixel[Colour];
    FVBRPixel[Colour] := Round(Y2 * FRAdjust[Colour]) + FPrevBRColour.Pixel[Colour];

    // Do some pre-calc stuff for horizontal gradient
    FTAdjust[Colour] := (FVTRPixel[Colour] - FVTLPixel[Colour]) / FShadeRect.Width;
    FBAdjust[Colour] := (FVBRPixel[Colour] - FVBLPixel[Colour]) / FShadeRect.Width;
  end;
end;

procedure TAHMCanvasGradientShade.ShadeChar(Rect: TAHMRectF);
var
  Colour: TColourType;
  X1, X2: Single;
begin
  // Calculate relative horizontal coordinates of this char
  X1 := Rect.X - FShadeRect.X;
  X2 := X1 + Rect.Width;

  for Colour := ctBlue to ctAlpha do
  begin
    // Compute top/bottom horizontal gradients
    FHTLPixel[Colour] := Round(X1 * FTAdjust[Colour]) + FVTLPixel[Colour];
    FHBLPixel[Colour] := Round(X1 * FBAdjust[Colour]) + FVBLPixel[Colour];
    FHTRPixel[Colour] := Round(X2 * FTAdjust[Colour]) + FVTLPixel[Colour];
    FHBRPixel[Colour] := Round(X2 * FBAdjust[Colour]) + FVBLPixel[Colour];
  end;

  // Update colour properties
  FTLColour.Pixel := FHTLPixel;
  FTRColour.Pixel := FHTRPixel;
  FBLColour.Pixel := FHBLPixel;
  FBRColour.Pixel := FHBRPixel;
end;

procedure TAHMCanvasGradientShade.ShadeRect(Rect: TAHMRectF);
begin
  // Only need to calculate colours if a shade rectangle has been set
  if ShadeRectSet then
  begin
    ShadeLine(Rect);
    ShadeChar(Rect);
  end;
end;

procedure TAHMCanvasGradientShade.ShadePoint(X, Y: Single);
var
  Colour: TColourType;
begin
  if not ShadeRectSet then Exit;

  // Calculate relative coordinates of this point
  Y := Y - FShadeRect.Y;
  X := X - FShadeRect.X;

  for Colour := ctBlue to ctAlpha do
  begin
    // Initialise top/bottom extents of vertical shade for this line
    FVTLPixel[Colour] := Round(Y * FLAdjust[Colour]) + FPrevTLColour.Pixel[Colour];
    FVTRPixel[Colour] := Round(Y * FRAdjust[Colour]) + FPrevTRColour.Pixel[Colour];

    // Do some pre-calc stuff for horizontal gradient
    FTAdjust[Colour] := (FVTRPixel[Colour] - FVTLPixel[Colour]) / FShadeRect.Width;
    FBAdjust[Colour] := (FVBRPixel[Colour] - FVBLPixel[Colour]) / FShadeRect.Width;

    // Compute pixel horizontal gradient colour
    FHTLPixel[Colour] := Round(X * FTAdjust[Colour]) + FVTLPixel[Colour];
  end;

  // Update colour properties
  FTLColour.Pixel := FHTLPixel;
  FTRColour.Pixel := FHTLPixel;
  FBLColour.Pixel := FHTLPixel;
  FBRColour.Pixel := FHTLPixel;
end;

// TAHMCanvasLinearShade

constructor TAHMCanvasLinearShade.Create;
begin
  inherited;

  FTLColour := TAHMCanvasColour.Create;
  FTRColour := TAHMCanvasColour.Create;
  FBLColour := TAHMCanvasColour.Create;
  FBRColour := TAHMCanvasColour.Create;

  FColours := TList.Create;
  FPositions := TList.Create;
  FCalcPos := TList.Create;
  FCalcDiff := TList.Create;
end;

destructor TAHMCanvasLinearShade.Destroy;
begin
  FTLColour.Free;
  FTRColour.Free;
  FBLColour.Free;
  FBRColour.Free;

  FColours.Free;
  FPositions.Free;
  FCalcPos.Free;
  FCalcDiff.Free;

  inherited;
end;

function TAHMCanvasLinearShade.GetValid: Boolean;
begin
  Result := FColours.Count > 1;
end;

function TAHMCanvasLinearShade.GetCount: Integer;
begin
  Result := FColours.Count;
end;

function TAHMCanvasLinearShade.GetPosition(Index: Integer): Single;
begin
  Result := Single(FPositions[Index]);
end;

function TAHMCanvasLinearShade.GetColour(Index: Integer): TAHMCanvasColour;
begin
  Result := TAHMCanvasColour(FColours[Index]);
end;

procedure TAHMCanvasLinearShade.SetupShadeRect;
var
  i: Integer;
  CalcPos, CalcDiff: Single;
begin
  // Pre-calculate fill position stops within rectangle bounds
  if FOrient = orHorizontal then
    for i := 0 to Pred(FPositions.Count) do
    begin
      CalcPos := FShadeRect.X + (Single(FPositions[i]) * FShadeRect.Width);
      FCalcPos[i] := Pointer(CalcPos);
    end
  else
    for i := 0 to Pred(FPositions.Count) do
    begin
      CalcPos := FShadeRect.Y + (Single(FPositions[i]) * FShadeRect.Height);
      FCalcPos[i] := Pointer(CalcPos);
    end;

  // Pre-calculate gaps between position stops
  for i := 1 to Pred(FCalcPos.Count) do
  begin
    CalcDiff := Single(FCalcPos[i]) - Single(FCalcPos[i - 1]);
    FCalcDiff[i] := Pointer(CalcDiff);
  end;
end;

procedure TAHMCanvasLinearShade.ShadeLine(Rect: TAHMRectF);
var
  Bottom, Diff, Y1, Y2: Single;
  Colour: TColourType;
  PixelT1, PixelT2, PixelB1, PixelB2: TColourPixel;
  i, Colour1, Colour2: Integer;
begin
  // We only need to shade lines for vertical fills
  if FOrient <> orVertical then Exit;

  // Determine top bounding colour gradient step for rectangle
  Colour1 := 0;
  for i := 1 to Pred(FColours.Count) do
    if Single(FCalcPos[i]) > Rect.Y then
    begin
      Colour1 := i - 1;
      Break;
    end;

  // Determine bottom bounding colour gradient step for rectangle
  Colour2 := Pred(FColours.Count);
  Bottom := Rect.Y + Rect.Height;
  for i := FColours.Count - 2 downto 0 do
    if Single(FCalcPos[i]) < Bottom then
    begin
      Colour2 := i + 1;
      Break;
    end;

  // Calculate top colour position (0..1) between gradient steps
  Diff := Single(FCalcDiff[Colour1 + 1]);
  if Diff > 0 then Y1 := (Rect.Y - Single(FCalcPos[Colour1])) / Diff
              else Y1 := 0;

  // Calculate bottom colour position (0..1) between gradient steps
  Diff := Single(FCalcDiff[Colour2]);
  if Diff > 0 then Y2 := (Bottom - Single(FCalcPos[Colour2 - 1])) / Diff
              else Y2 := 0;

  // Calculate top and bottom gradient colours
  PixelT1 := TAHMCanvasColour(FColours[Colour1]).Pixel;
  PixelT2 := TAHMCanvasColour(FColours[Colour1 + 1]).Pixel;
  PixelB1 := TAHMCanvasColour(FColours[Colour2 - 1]).Pixel;
  PixelB2 := TAHMCanvasColour(FColours[Colour2]).Pixel;
  for Colour := ctBlue to ctAlpha do
  begin
    FTLPixel[Colour] := Round(PixelT1[Colour] + ((PixelT2[Colour] - PixelT1[Colour]) * Y1));
    FBLPixel[Colour] := Round(PixelB1[Colour] + ((PixelB2[Colour] - PixelB1[Colour]) * Y2));
  end;

  // Update colour properties for bottom corners
  FTLColour.Pixel := FTLPixel;
  FBLColour.Pixel := FBLPixel;
  FTRColour.Pixel := FTLPixel;
  FBRColour.Pixel := FBLPixel;
end;

procedure TAHMCanvasLinearShade.ShadeChar(Rect: TAHMRectF);
var
  Right, Diff, X1, X2: Single;
  Colour: TColourType;
  PixelL1, PixelL2, PixelR1, PixelR2: TColourPixel;
  i, Colour1, Colour2: Integer;
begin
  // We only need to shade chars for horizontal fills
  if FOrient <> orHorizontal then Exit;

  // Determine left bounding colour gradient step for rectangle
  Colour1 := 0;
  for i := 1 to Pred(FColours.Count) do
    if Single(FCalcPos[i]) > Rect.X then
    begin
      Colour1 := i - 1;
      Break;
    end;

  // Determine right bounding colour gradient step for rectangle
  Colour2 := Pred(FColours.Count);
  Right := Rect.X + Rect.Width;
  for i := FColours.Count - 2 downto 0 do
    if Single(FCalcPos[i]) < Right then
    begin
      Colour2 := i + 1;
      Break;
    end;

  // Calculate left colour position (0..1) between gradient steps
  Diff := Single(FCalcDiff[Colour1 + 1]);
  if Diff > 0 then X1 := (Rect.X - Single(FCalcPos[Colour1])) / Diff
              else X1 := 0;

  // Calculate right colour position (0..1) between gradient steps
  Diff := Single(FCalcDiff[Colour2]);
  if Diff > 0 then X2 := (Right - Single(FCalcPos[Colour2 - 1])) / Diff
              else X2 := 0;

  // Calculate left and right gradient colours
  PixelL1 := TAHMCanvasColour(FColours[Colour1]).Pixel;
  PixelL2 := TAHMCanvasColour(FColours[Colour1 + 1]).Pixel;
  PixelR1 := TAHMCanvasColour(FColours[Colour2 - 1]).Pixel;
  PixelR2 := TAHMCanvasColour(FColours[Colour2]).Pixel;
  for Colour := ctBlue to ctAlpha do
  begin
    FTLPixel[Colour] := Round(PixelL1[Colour] + ((PixelL2[Colour] - PixelL1[Colour]) * X1));
    FTRPixel[Colour] := Round(PixelR1[Colour] + ((PixelR2[Colour] - PixelR1[Colour]) * X2));
  end;

  // Update colour properties for bottom corners
  FTLColour.Pixel := FTLPixel;
  FBLColour.Pixel := FTLPixel;
  FTRColour.Pixel := FTRPixel;
  FBRColour.Pixel := FTRPixel;
end;

procedure TAHMCanvasLinearShade.ShadeRect(Rect: TAHMRectF);
begin
  // Perform shader setup if not already done so
  if not ShadeRectSet then
  begin
    FShadeRect := Rect;
    SetupShadeRect;
  end;

  // One of these will work depending on orientation
  ShadeLine(Rect);
  ShadeChar(Rect);
end;

procedure TAHMCanvasLinearShade.ShadePoint(X, Y: Single);
var
  Diff, PointVal, ColourVal: Single;
  Colour: TColourType;
  Pixel1, Pixel2: TColourPixel;
  i, ColourIdx: Integer;
begin
  if not ShadeRectSet then Exit;

  // Use appropriate coordinate depending on fill orientation
  if FOrient = orVertical then PointVal := Y else PointVal := X;

  // Determine top/left bounding colour gradient step for point
  ColourIdx := 0;
  for i := 1 to Pred(FColours.Count) do
    if Single(FCalcPos[i]) > PointVal then
    begin
      ColourIdx := i - 1;
      Break;
    end;

  // Calculate top/left colour position (0..1) between gradient steps
  Diff := Single(FCalcDiff[ColourIdx + 1]);
  if Diff > 0 then ColourVal := (PointVal - Single(FCalcPos[ColourIdx])) / Diff
              else ColourVal := 0;

  // Calculate top/left and bottom/right gradient colours
  Pixel1 := TAHMCanvasColour(FColours[ColourIdx]).Pixel;
  Pixel2 := TAHMCanvasColour(FColours[ColourIdx + 1]).Pixel;
  for Colour := ctBlue to ctAlpha do
    FTLPixel[Colour] := Round(Pixel1[Colour] + ((Pixel2[Colour] - Pixel1[Colour]) * ColourVal));

  // Update colour property for single colour
  FTLColour.Pixel := FTLPixel;
end;

procedure TAHMCanvasLinearShade.Clear;
begin
  FColours.Clear;
  FPositions.Clear;
  FCalcPos.Clear;
  FCalcDiff.Clear;
end;

procedure TAHMCanvasLinearShade.Add(Position: Single; Colour: TAHMCanvasColour);
begin
  if Assigned(Colour) then
  begin
    FColours.Add(Colour);
    FPositions.Add(Pointer(Position));
    FCalcPos.Add(nil); // Placeholder
    FCalcDiff.Add(nil); // Placeholder
  end;
end;

initialization
  BlackInstance := nil;
  WhiteInstance := nil;
  GreyInstance := nil;
  HighlightInstance := nil;
  GradientLoInstance := nil;
  GradientHiInstance := nil;

finalization
  BlackInstance.Free;
  WhiteInstance.Free;
  GreyInstance.Free;
  HighlightInstance.Free;
  GradientLoInstance.Free;
  GradientHiInstance.Free;

end.
